home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH10 / SRC / OBJFRACT.CLS < prev    next >
Text File  |  1996-05-04  |  17KB  |  608 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "ObjFractalGrid"
  6. Attribute VB_Creatable = False
  7. Attribute VB_Exposed = False
  8. Option Explicit
  9.  
  10. Private Xmin As Single      ' Min X and Y values.
  11. Private Zmin As Single
  12. Private Dx As Single        ' Spacing between rows of data.
  13. Private Dz As Single
  14. Private NumX As Integer     ' Number of X and Y entries.
  15. Private NumZ As Integer
  16. Private Points() As Point3D ' Data values.
  17.  
  18. Private RemoveHidden As Boolean ' Remove hidden surfaces?
  19.  
  20. ' ************************************************
  21. ' Generate the fractal surface.
  22. ' ************************************************
  23. Public Sub GenerateSurface(divisions As Integer, Dy As Single)
  24. Dim oldpoints() As Point3D
  25. Dim oldx As Integer
  26. Dim oldz As Integer
  27. Dim factor As Integer
  28. Dim newx As Integer
  29. Dim newz As Integer
  30. Dim i As Integer
  31. Dim j As Integer
  32. Dim newi As Integer
  33. Dim newj As Integer
  34.  
  35.     ' Make room for the new data.
  36.     factor = 2 ^ divisions
  37.     newx = (NumX - 1) * factor + 1
  38.     newz = (NumZ - 1) * factor + 1
  39.  
  40.     ' Copy the original data.
  41.     ReDim oldpoints(1 To NumX, 1 To NumZ)
  42.     For i = 1 To NumX
  43.         For j = 1 To NumZ
  44.             oldpoints(i, j) = Points(i, j)
  45.         Next j
  46.     Next i
  47.  
  48.     ' Resize and initialize the Points array.
  49.     oldx = NumX
  50.     oldz = NumZ
  51.     SetBounds Xmin, Dx / factor, newx, _
  52.               Zmin, Dz / factor, newz
  53.     
  54.     ' Move the data to new positions.
  55.     newi = 1
  56.     For i = 1 To oldx
  57.         newj = 1
  58.         For j = 1 To oldz
  59.             Points(newi, newj) = oldpoints(i, j)
  60.             newj = newj + factor
  61.         Next j
  62.         newi = newi + factor
  63.     Next i
  64.     
  65.     ' Subdivide each area in the data.
  66.     newi = 1
  67.     For i = 2 To oldx
  68.         newj = 1
  69.         For j = 2 To oldz
  70.             Subdivide newi, newi + factor, _
  71.                       newj, newj + factor, Dy
  72.             newj = newj + factor
  73.         Next j
  74.         newi = newi + factor
  75.     Next i
  76. End Sub
  77.  
  78. ' ************************************************
  79. ' Let the user decide if we should draw hidden
  80. ' surfaces.
  81. ' ************************************************
  82. Property Let ShowHidden(value As Boolean)
  83.     RemoveHidden = Not value
  84. End Property
  85. ' ************************************************
  86. ' Tell the user if we are drawing hidden surfaces.
  87. ' ************************************************
  88. Property Get ShowHidden() As Boolean
  89.     ShowHidden = Not RemoveHidden
  90. End Property
  91.  
  92.  
  93. ' ************************************************
  94. ' Draw a line between the points. Set the hi and
  95. ' lo values for the line.
  96. ' ************************************************
  97. Sub DrawAndSetLine(canvas As Object, ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single, ByVal y2 As Single, hi() As Integer, lo() As Integer)
  98. Dim tmp As Single
  99. Dim ix As Integer
  100. Dim iy As Integer
  101. Dim y As Single
  102. Dim Dy As Single
  103.  
  104.     ' Deal only with integers.
  105.     x1 = CInt(x1)
  106.     y1 = CInt(y1)
  107.     x2 = CInt(x2)
  108.     y2 = CInt(y2)
  109.         
  110.     ' Make x1 < x2.
  111.     If x2 < x1 Then
  112.         tmp = x1
  113.         x1 = x2
  114.         x2 = tmp
  115.         tmp = y1
  116.         y1 = y2
  117.         y2 = tmp
  118.     End If
  119.         
  120.     ' Draw the line.
  121.     canvas.Line (x1, y1)-(x2, y2)
  122.     
  123.     ' Deal with vertical lines separately.
  124.     If x1 = x2 Then
  125.         If y1 < y2 Then
  126.             lo(x1) = y1
  127.             hi(x1) = y2
  128.         Else
  129.             lo(x1) = y2
  130.             hi(x1) = y1
  131.         End If
  132.         Exit Sub
  133.     End If
  134.     
  135.     ' Deal with non-vertical lines.
  136.     Dy = (y2 - y1) / CInt(x2 - x1)
  137.     y = y1
  138.     For ix = x1 To x2
  139.         iy = CInt(y)
  140.         
  141.         lo(ix) = iy
  142.         hi(ix) = iy
  143.         
  144.         y = y + Dy
  145.     Next ix
  146. End Sub
  147.  
  148.  
  149.  
  150.  
  151. ' ************************************************
  152. ' Draw a line between the points using and
  153. ' updating the hi and lo arrays.
  154. ' ************************************************
  155. Sub DrawLine(canvas As Object, ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single, ByVal y2 As Single, hi() As Integer, lo() As Integer)
  156. Dim tmp As Single
  157. Dim ix As Integer
  158. Dim iy As Integer
  159. Dim y As Single
  160. Dim Dy As Single
  161. Dim firstx As Integer
  162. Dim firsty As Integer
  163. Dim skipping As Boolean
  164. Dim above As Boolean
  165.  
  166.     ' Deal only with integers.
  167.     x1 = CInt(x1)
  168.     y1 = CInt(y1)
  169.     x2 = CInt(x2)
  170.     y2 = CInt(y2)
  171.  
  172.     ' Make x1 < x2.
  173.     If x2 < x1 Then
  174.         tmp = x1
  175.         x1 = x2
  176.         x2 = tmp
  177.         tmp = y1
  178.         y1 = y2
  179.         y2 = tmp
  180.     End If
  181.         
  182.     ' Deal with vertical lines separately.
  183.     If x1 = x2 Then
  184.         ' Make y1 < y2.
  185.         If y2 < y1 Then
  186.             tmp = y1
  187.             y1 = y2
  188.             y2 = tmp
  189.         End If
  190.         If y1 <= lo(x1) Then
  191.             If y2 <= lo(x1) Then
  192.                 canvas.Line (x1, y1)-(x2, y2)
  193.             Else
  194.                 canvas.Line (x1, y1)-(x2, lo(x2))
  195.             End If
  196.             lo(x1) = y1
  197.         End If
  198.         If y2 >= hi(x2) Then
  199.             If y1 >= hi(x2) Then
  200.                 canvas.Line (x1, y1)-(x2, y2)
  201.             Else
  202.                 canvas.Line (x1, hi(x1))-(x2, y2)
  203.             End If
  204.             hi(x2) = y2
  205.         End If
  206.         Exit Sub
  207.     End If
  208.     
  209.     ' Deal with non-vertical lines.
  210.     Dy = (y2 - y1) / CInt(x2 - x1)
  211.     y = y1
  212.     
  213.     ' Find the first visible point.
  214.     skipping = True
  215.     For ix = x1 To x2
  216.         iy = CInt(y)
  217.         ' See if this point is visible.
  218.         If iy <= lo(ix) Then
  219.             If skipping Then
  220.                 ' Start a new line below.
  221.                 firstx = ix
  222.                 firsty = lo(ix)
  223.                 skipping = False
  224.                 above = False
  225.             End If
  226.         ElseIf iy >= hi(ix) Then
  227.             If skipping Then
  228.                 ' Start a new line above.
  229.                 firstx = ix
  230.                 firsty = hi(ix)
  231.                 skipping = False
  232.                 above = True
  233.             End If
  234.         Else
  235.             ' This point is not visible.
  236.             If Not skipping Then
  237.                 ' Draw the previous visible line.
  238.                 If above Then
  239.                     ' The line is coming from
  240.                     ' above. Connect it to hi(ix).
  241.                     canvas.Line (firstx, firsty)-(ix, hi(ix))
  242.                 Else
  243.                     ' The line is coming from
  244.                     ' below. Connect it to lo(ix).
  245.                     canvas.Line (firstx, firsty)-(ix, lo(ix))
  246.                 End If
  247.                 
  248.                 skipping = True
  249.             End If
  250.         End If
  251.         
  252.         If iy < lo(ix) Then lo(ix) = iy
  253.         If iy > hi(ix) Then hi(ix) = iy
  254.         
  255.         y = y + Dy
  256.     Next ix
  257.  
  258.     ' Draw to the last point if necessary.
  259.     If Not skipping Then _
  260.         canvas.Line (firstx, firsty)-(x2, y2)
  261. End Sub
  262.  
  263.  
  264.  
  265. ' ************************************************
  266. ' Create the Points array.
  267. ' ************************************************
  268. Sub SetBounds(x1 As Single, deltax As Single, xnum As Integer, z1 As Single, deltaz As Single, znum As Integer)
  269. Dim i As Integer
  270. Dim j As Integer
  271. Dim x As Single
  272. Dim z As Single
  273.  
  274.     Xmin = x1
  275.     Zmin = z1
  276.     Dx = deltax
  277.     Dz = deltaz
  278.     NumX = xnum
  279.     NumZ = znum
  280.     ReDim Points(1 To NumX, 1 To NumZ)
  281.     
  282.     x = Xmin
  283.     For i = 1 To NumX
  284.         z = Zmin
  285.         For j = 1 To NumZ
  286.             Points(i, j).coord(1) = x
  287.             Points(i, j).coord(2) = 0
  288.             Points(i, j).coord(3) = z
  289.             Points(i, j).coord(4) = 1#
  290.             z = z + Dz
  291.         Next j
  292.         x = x + Dx
  293.     Next i
  294. End Sub
  295.  
  296. ' ************************************************
  297. ' Recursively subdivide the indicated area.
  298. ' ************************************************
  299. Private Sub Subdivide(i1 As Integer, i2 As Integer, j1 As Integer, j2 As Integer, Dy As Single)
  300. Dim y11 As Single
  301. Dim y12 As Single
  302. Dim y21 As Single
  303. Dim y22 As Single
  304. Dim imid As Integer
  305. Dim jmid As Integer
  306.  
  307.     If i2 - i1 <= 1 Or j2 - j1 <= 1 Then Exit Sub
  308.  
  309.     ' Compute the midpoint locations.
  310.     y11 = Points(i1, j1).coord(2)
  311.     y12 = Points(i1, j2).coord(2)
  312.     y21 = Points(i2, j1).coord(2)
  313.     y22 = Points(i2, j2).coord(2)
  314.     
  315.     imid = (i1 + i2) \ 2
  316.     jmid = (j1 + j2) \ 2
  317.     Points(i1, jmid).coord(2) = (y11 + y12) / 2 + 2 * Dy * Rnd - Dy
  318.     Points(i2, jmid).coord(2) = (y21 + y22) / 2 + 2 * Dy * Rnd - Dy
  319.     Points(imid, j1).coord(2) = (y11 + y21) / 2 + 2 * Dy * Rnd - Dy
  320.     Points(imid, j2).coord(2) = (y12 + y22) / 2 + 2 * Dy * Rnd - Dy
  321.     Points(imid, jmid).coord(2) = (y11 + y12 + y21 + y22) / 4 + 2 * Dy * Rnd - Dy
  322.  
  323.     ' Recursively subdivide the four new areas.
  324.     Subdivide i1, imid, j1, jmid, Dy / 2
  325.     Subdivide imid, i2, j1, jmid, Dy / 2
  326.     Subdivide i1, imid, jmid, j2, Dy / 2
  327.     Subdivide imid, i2, jmid, j2, Dy / 2
  328. End Sub
  329.  
  330.  
  331. ' ************************************************
  332. ' Save the indicated data value.
  333. ' ************************************************
  334. Sub SetValue(x As Single, y As Single, z As Single)
  335. Dim i As Integer
  336. Dim j As Integer
  337.  
  338.     i = (x - Xmin) / Dx + 1
  339.     j = (z - Zmin) / Dz + 1
  340.     Points(i, j).coord(2) = y
  341. End Sub
  342.  
  343. ' ***********************************************
  344. ' Return a string indicating the object type.
  345. ' ***********************************************
  346. Property Get ObjectType() As String
  347.     ObjectType = "FRACTALGRID"
  348. End Property
  349.  
  350.  
  351.  
  352. ' ***********************************************
  353. ' Fix the data coordinates at their transformed
  354. ' values.
  355. ' ***********************************************
  356. Public Sub FixPoints()
  357. Dim i As Integer
  358. Dim j As Integer
  359. Dim k As Integer
  360.  
  361.     For i = 1 To NumX
  362.         For j = 1 To NumZ
  363.             For k = 1 To 3
  364.                 Points(i, j).coord(k) = Points(i, j).trans(k)
  365.             Next k
  366.         Next j
  367.     Next i
  368. End Sub
  369.  
  370. ' ************************************************
  371. ' Apply a transformation matrix which may not
  372. ' contain 0, 0, 0, 1 in the last column to the
  373. ' object.
  374. ' ************************************************
  375. Public Sub ApplyFull(M() As Single)
  376. Dim i As Integer
  377. Dim j As Integer
  378.  
  379.     For i = 1 To NumX
  380.         For j = 1 To NumZ
  381.             m3ApplyFull Points(i, j).coord, M, Points(i, j).trans
  382.         Next j
  383.     Next i
  384. End Sub
  385.  
  386. ' ************************************************
  387. ' Apply a transformation matrix to the object.
  388. ' ************************************************
  389. Public Sub Apply(M() As Single)
  390. Dim i As Integer
  391. Dim j As Integer
  392.  
  393.     For i = 1 To NumX
  394.         For j = 1 To NumZ
  395.             m3Apply Points(i, j).coord, M, Points(i, j).trans
  396.         Next j
  397.     Next i
  398. End Sub
  399.  
  400.  
  401. ' ************************************************
  402. ' Apply a nonlinear transformation.
  403. ' ************************************************
  404. Public Sub Distort(D As Object)
  405. Dim i As Integer
  406. Dim j As Integer
  407.  
  408.     For i = 1 To NumX
  409.         For j = 1 To NumZ
  410.             D.Distort Points(i, j).coord(1), Points(i, j).coord(2), Points(i, j).coord(3)
  411.         Next j
  412.     Next i
  413. End Sub
  414.  
  415.  
  416. ' ************************************************
  417. ' Draw the grid without hidden surfaces using the
  418. ' hi-lo algorithm.
  419. ' ************************************************
  420. Public Sub DrawWithoutHidden(canvas As Object, Optional R As Variant)
  421. Dim Xmin As Integer
  422. Dim Xmax As Integer
  423. Dim lo() As Integer
  424. Dim hi() As Integer
  425. Dim ix As Integer
  426. Dim i As Integer
  427. Dim j As Integer
  428.     
  429.     ' Bound the X values.
  430.     Xmin = Points(1, 1).trans(1)
  431.     Xmax = Xmin
  432.     For i = 1 To NumX
  433.         For j = 1 To NumZ
  434.             ix = CInt(Points(i, j).trans(1))
  435.             If Xmin > ix Then Xmin = ix
  436.             If Xmax < ix Then Xmax = ix
  437.         Next j
  438.     Next i
  439.     
  440.     ' Create the hi and lo arrays.
  441.     ReDim lo(Xmin To Xmax)
  442.     ReDim hi(Xmin To Xmax)
  443.     
  444.     ' Draw the X and Z front edges.
  445.     For i = 2 To NumX
  446.         ' Draw the edge between
  447.         ' Points(i - 1, NumZ) and Points(i, NumZ)
  448.         ' and set hi and lo for its values.
  449.         DrawAndSetLine canvas, _
  450.             Points(i - 1, NumZ).trans(1), _
  451.             Points(i - 1, NumZ).trans(2), _
  452.             Points(i, NumZ).trans(1), _
  453.             Points(i, NumZ).trans(2), _
  454.             hi, lo
  455.     Next i
  456.     For i = 2 To NumZ
  457.         ' Draw the edge between
  458.         ' Points(NumX, i - 1) and Points(NumX, i)
  459.         ' and set hi and lo for its values.
  460.         DrawAndSetLine canvas, _
  461.             Points(NumX, i - 1).trans(1), _
  462.             Points(NumX, i - 1).trans(2), _
  463.             Points(NumX, i).trans(1), _
  464.             Points(NumX, i).trans(2), _
  465.             hi, lo
  466.     Next i
  467.     
  468.     ' Draw the "rectangles."
  469.     For i = NumX - 1 To 1 Step -1
  470.         For j = NumZ - 1 To 1 Step -1
  471.             ' Draw the edges between:
  472.             '   Points(i, j) and Points(i + 1, j)
  473.             '   Points(i, j) and Points(i, j + 1)
  474.             
  475.             ' If the right side of the "rectangle"
  476.             ' leans over the top like this:
  477.             '    +_
  478.             '    | \_
  479.             '    |   \_
  480.             '    +     \_
  481.             '     \      \
  482.             '      +------+
  483.             ' draw the top first so the right side
  484.             ' doesn't make hi() too bit and stop
  485.             ' the top from being drawn.
  486.             '
  487.             ' This only happens with perspective
  488.             ' projection.
  489.             If Points(i + 1, j).trans(1) >= Points(i, j).trans(1) Then
  490.                 DrawLine canvas, _
  491.                     Points(i, j).trans(1), _
  492.                     Points(i, j).trans(2), _
  493.                     Points(i, j + 1).trans(1), _
  494.                     Points(i, j + 1).trans(2), _
  495.                     hi, lo
  496.                 DrawLine canvas, _
  497.                     Points(i, j).trans(1), _
  498.                     Points(i, j).trans(2), _
  499.                     Points(i + 1, j).trans(1), _
  500.                     Points(i + 1, j).trans(2), _
  501.                     hi, lo
  502.             Else
  503.                 DrawLine canvas, _
  504.                     Points(i, j).trans(1), _
  505.                     Points(i, j).trans(2), _
  506.                     Points(i + 1, j).trans(1), _
  507.                     Points(i + 1, j).trans(2), _
  508.                     hi, lo
  509.                 DrawLine canvas, _
  510.                     Points(i, j).trans(1), _
  511.                     Points(i, j).trans(2), _
  512.                     Points(i, j + 1).trans(1), _
  513.                     Points(i, j + 1).trans(2), _
  514.                     hi, lo
  515.             End If
  516.         Next j
  517.     Next i
  518. End Sub
  519.  
  520. ' ************************************************
  521. ' Draw the grid including hidden surfaces.
  522. ' ************************************************
  523. Public Sub DrawWithHidden(canvas As Object, Optional R As Variant)
  524. Dim i As Integer
  525. Dim j As Integer
  526.  
  527.     On Error Resume Next
  528.         
  529.     ' Draw lines parallel to the X axis.
  530.     For i = 1 To NumX
  531.         canvas.CurrentX = Points(i, 1).trans(1)
  532.         canvas.CurrentY = Points(i, 1).trans(2)
  533.         For j = 2 To NumZ
  534.             canvas.Line -(Points(i, j).trans(1), _
  535.                           Points(i, j).trans(2))
  536.         Next j
  537.     Next i
  538.     
  539.     ' Draw lines parallel to the Y axis.
  540.     For j = 1 To NumZ
  541.         canvas.CurrentX = Points(1, j).trans(1)
  542.         canvas.CurrentY = Points(1, j).trans(2)
  543.         For i = 2 To NumX
  544.             canvas.Line -(Points(i, j).trans(1), _
  545.                           Points(i, j).trans(2))
  546.         Next i
  547.     Next j
  548. End Sub
  549.  
  550. ' ************************************************
  551. ' Draw the transformed points on a Form, Printer,
  552. ' or PictureBox.
  553. ' ************************************************
  554. Public Sub Draw(canvas As Object, Optional R As Variant)
  555.     If RemoveHidden Then
  556.         DrawWithoutHidden canvas, R
  557.     Else
  558.         DrawWithHidden canvas, R
  559.     End If
  560. End Sub
  561. ' ************************************************
  562. ' Write a grid to a file using Write.
  563. ' Begin with "FRACTALGRID" to identify this object.
  564. ' ************************************************
  565. Public Sub FileWrite(filenum As Integer)
  566. Dim i As Integer
  567. Dim j As Integer
  568.  
  569.     ' Write basic information.
  570.     Write #filenum, _
  571.         "FRACTALGRID", Xmin, Zmin, Dx, Dz, NumX, NumZ
  572.         
  573.     ' Write the Z values.
  574.     For i = 1 To NumX
  575.         For j = 1 To NumZ
  576.             Write #filenum, Points(i, j).coord(2)
  577.         Next j
  578.     Next i
  579. End Sub
  580.  
  581. ' ************************************************
  582. ' Read a grid from a file using Input.
  583. ' Assume the "FRACTALGRID" label has alreaDz been
  584. ' read.
  585. ' ************************************************
  586. Public Sub FileInput(filenum As Integer)
  587. Dim i As Integer
  588. Dim j As Integer
  589.  
  590.     ' Get the basic information.
  591.     Input #filenum, Xmin, Zmin, Dx, Dz, NumX, NumZ
  592.     
  593.     ' Allocate the Points array and set the X and
  594.     ' Y values.
  595.     SetBounds Xmin, Dx, NumX, Zmin, Dz, NumZ
  596.     
  597.     ' Read the Z values.
  598.     For i = 1 To NumX
  599.         For j = 1 To NumZ
  600.             Input #filenum, Points(i, j).coord(2)
  601.         Next j
  602.     Next i
  603. End Sub
  604.  
  605.  
  606.  
  607.  
  608.